home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 011 / autodesk.arc / TABLES.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1987-01-27  |  12.0 KB  |  362 lines
  1.  
  2. ;  TABLES.LSP
  3.  
  4. ;  Exerciser for (TBLNEXT) and (TBLSEARCH) functions.
  5.  
  6. ;  The functions (LAYERS), (LTYPES), (VIEWS), (STYLES), and (BLOCKS)
  7. ;  can be called independently.  Each lists the entries in the
  8. ;  associated symbol table, optionally in alphabetical order.  The
  9. ;  TABLES command ((C:TABLES) funciton) calls each of them in turn.
  10.  
  11. ;  For the layer, linetype, and text style tables, an asterisk in column
  12. ;  one marks the current setting.  If the current linetype is "BYLAYER",
  13. ;  the linetype corresponding to the current layer will be marked with
  14. ;  an "L" in column one.
  15.  
  16. ;  by Duff Kurland - Autodesk, Inc.
  17. ;  October 12, 1986
  18.  
  19.  
  20. ;  (LAYERS) - Dump the layer table
  21.  
  22. (defun layers ( / c d f ln lt ly n x)
  23.    (tblset "layer")
  24.    (write-line "  Layer       Status  Color  Linetype    Description")
  25.    (terpri)
  26.    (setq cl (getvar "clayer"))          ; get current layer
  27.    (setq n  0)
  28.    (setq x  (next T))                   ; get first layer
  29.    (while x
  30.       (setq n  (1+ n)
  31.             ly (fld  2 x)               ; layer name
  32.             ln (fld  6 x)               ; linetype name
  33.             c  (fld 62 x)               ; color number
  34.             f  (logand (fld 70 x) 1)    ; "frozen" flag
  35.             lt (tblsearch "ltype" ln)   ; linetype table entry
  36.             d  (fld  3 lt)              ; linetype prose description
  37.       )
  38.       (write-line
  39.          (strcat
  40.             (if (= ly cl) "* " "  ")    ; flag current layer
  41.             (strfill ly 12)             ; edit layer name
  42.             (strfill
  43.                (cond ((= f 1) "Frozen") ; edit status
  44.                      ((< c 0) "Off")
  45.                      (T       "On")
  46.                ) 8
  47.             )
  48.             (strfill (itoa (abs c)) 7)  ; edit color number
  49.             (strfill ln 12)             ; edit linetype name
  50.             (substr d 1 30)             ; edit linetype description
  51.          )
  52.       )
  53.       (setq x (next nil))               ; get next layer entry
  54.    )
  55.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  56.    nil
  57. )
  58.  
  59.  
  60. ;  (LTYPES) - Dump the linetype table
  61.  
  62. (defun ltypes ( / a cl d f lt n s x)
  63.    (tblset "ltype")
  64.    (write-line "  Linetype    Align  Segs  Description")
  65.    (terpri)
  66.    (setq cl (getvar "celtype"))         ; get current linetype
  67.    (setq f  "* ")                       ; set default "current" flag
  68.  
  69.    ;  If current linetype is "BYLAYER", look up the linetype
  70.    ;  associated with the current layer, and change the
  71.    ;  "current" flag from "* " to "L ".
  72.  
  73.    (setq cl
  74.       (cond ((= cl "BYBLOCK") "")
  75.             ((= cl "BYLAYER") (setq f "L ")
  76.                               (fld 6 (tblsearch "layer" (getvar "clayer"))))
  77.             (T cl)
  78.       )
  79.    )
  80.    (setq n 0)
  81.    (setq x (next T))                    ; first linetype
  82.    (while x
  83.       (setq n  (1+ n)
  84.             lt (fld  2 x)               ; linetype name
  85.             d  (fld  3 x)               ; linetype prose description
  86.             a  (fld 72 x)               ; alignment code
  87.             s  (fld 73 x)               ; number of dash length items
  88.       )
  89.       (write-line
  90.          (strcat
  91.             (if (= lt cl) f "  ")       ; flag current entity linetype
  92.             (strfill lt 12)             ; edit layer name
  93.             (strfill (chr a) 7)         ; alignment code
  94.             (strfill (itoa s) 6)        ; number of dash length items
  95.             (substr d 1 30)             ; linetype description
  96.          )
  97.       )
  98.       (if (> s 0) (progn
  99.  
  100.          ;  Edit dash length items
  101.  
  102.          (setq x (member (assoc 49 x) x)) ; get list of dash items
  103.          (while x
  104.             (setq s (cdar x))           ; get dash length
  105.             (write-line
  106.                (strcat
  107.                   (strfill " " 27)
  108.                   (cond ((= s 0) "Dot")
  109.                         ((> s 0) (strcat "Pen down " (rtos s 2 4)))
  110.                         (T       (strcat "Pen up   " (rtos (abs s) 2 4)))
  111.                   )
  112.                )
  113.             )
  114.             (setq x (cdr x))            ; get next dash item
  115.          )
  116.       ))
  117.       (setq x (next nil))               ; get next linetype entry
  118.    )
  119.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  120.    nil
  121. )
  122.  
  123.  
  124. ;  (VIEWS) - Dump the named view table
  125.  
  126. (defun views ( / c d h n v w x z)
  127.    (tblset "view")
  128.    (write-line "  View        Height x Width    Center            Direction")
  129.    (terpri)
  130.    (setq n 0)
  131.    (setq x (next T))                    ; get first view
  132.    (while x
  133.       (setq n  (1+ n)
  134.             v  (fld  2 x)               ; view name
  135.             c  (fld 10 x)               ; center point
  136.             d  (fld 11 x)               ; X,Y of direction
  137.             z  (fld 31 x)               ; Z of direction
  138.             h  (fld 40 x)               ; height
  139.             w  (fld 41 x)               ; width (valid only for windows)
  140.       )
  141.       (write-line
  142.          (strcat
  143.             "  "
  144.             (strfill v 12)              ; edit view name
  145.             (strfill (strcat (rtos h 2 4)   ; edit height x width
  146.                              "x"
  147.                              (rtos w 2 4)) 18
  148.             )
  149.             (strfill (strcat (rtos (car c) 2 4)  ; edit center point
  150.                              ","
  151.                              (rtos (cadr c) 2 4)) 18
  152.             )
  153.             (rtos (car d) 2 4)          ; edit X portion of direction
  154.             ","
  155.             (rtos (cadr d) 2 4)         ; edit Y portion of direction
  156.             ","
  157.             (rtos z 2 4)                ; edit Z portion of direction
  158.          )
  159.       )
  160.       (setq x (next nil))               ; get next view entry
  161.    )
  162.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  163.    nil
  164. )
  165.  
  166.  
  167. ;  (STYLES) - Dump the text style table
  168.  
  169. (defun styles ( / cs fb ff g h n o s w x)
  170.    (tblset "style")
  171.    (write-line "  Text style  Height  Width   Slant  Flags  Font      Bigfont")
  172.    (terpri)
  173.    (setq cs (getvar "textstyle"))       ; get current style
  174.    (setq n  0)
  175.    (setq x  (next T))                   ; get first style
  176.    (while x
  177.       (setq n  (1+ n)
  178.             s  (fld  2 x)               ; style name
  179.             ff (fld  3 x)               ; primary font file
  180.             fb (fld  4 x)               ; big font file
  181.             h  (fld 40 x)               ; height
  182.             w  (fld 41 x)               ; width factor
  183.             o  (fld 50 x)               ; obliquing angle
  184.             g  (fld 71 x)               ; generation flags
  185.       )
  186.       (write-line
  187.          (strcat
  188.             (if (= s cs) "* " "  ")     ; flag current style
  189.             (strfill s 12)              ; edit style name
  190.             (strfill (rtos h 2 4) 8)    ; height
  191.             (strfill (rtos w 2 4) 8)    ; width factor
  192.             (strfill (angtos o 0 2) 7)  ; obliquing angle
  193.             (strfill (itoa g) 7)        ; generation flags
  194.             (strfill ff 10)             ; primary font file
  195.             fb                          ; big font file
  196.          )
  197.       )
  198.       (setq x (next nil))               ; get next style entry
  199.    )
  200.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  201.    nil
  202. )
  203.  
  204.  
  205. ;  (BLOCKS) - Dump the block definition table
  206.  
  207. (defun blocks ( / b e ec ed et f n o x)
  208.    (tblset "block")
  209.    (write-line "  Block       Flags  Origin")
  210.    (terpri)
  211.    (setq n 0)
  212.    (setq x (next T))                    ; get first block definition
  213.    (while x
  214.       (setq n  (1+ n)
  215.             b  (fld  2 x)               ; block name
  216.             o  (fld 10 x)               ; origin X,Y,Z
  217.             f  (fld 70 x)               ; flags
  218.       )
  219.       (write-line
  220.            (strcat
  221.                 "  "
  222.                 (strfill b 12)          ; edit block name
  223.                 (strfill (itoa f) 7)    ; flags
  224.                 (rtos (car o) 2 4)      ; origin X
  225.                 ","
  226.                 (rtos (cadr o) 2 4)     ; origin Y
  227.                 ","
  228.                 (rtos (caddr o) 2 4)    ; origin Z
  229.            )
  230.       )
  231.  
  232.       ;  Display interesting facts about the entities comprising
  233.       ;  this block definition.
  234.  
  235.       (setq e (fld -2 x))               ; point to first entity
  236.       (while e
  237.            (setq ed (entget e))         ; get the entity data
  238.            (setq et (fld  0 ed))        ; entity type
  239.            (setq ec (fld 62 ed))        ; entity color
  240.            (write-line
  241.                (strcat
  242.                    (strfill " " 14)
  243.                    (strfill et 9)       ; edit entity type
  244.                    " on layer "
  245.                    (fld 8 ed)           ; edit layer name
  246.                    " with color "
  247.                    (cond ((= ec 0)  "BYBLOCK")  ; edit color number
  248.                          ((null ec) "BYLAYER")
  249.                          (T         (itoa ec))
  250.                    )
  251.                )
  252.            )
  253.            (if (setq e (entnext e))     ; if there's another entity,
  254.                (setq ed (entget e))     ;   read its data
  255.            )
  256.       )
  257.       (terpri)
  258.       (setq x (next nil))               ; get next block entry
  259.    )
  260.    (princ (if (= n 0) "  -None-\n\n" "\n"))
  261.    nil
  262. )
  263.  
  264. ;  Blank-fill the given string to a specified number of characters
  265.  
  266. (defun strfill (s len)
  267.    (substr (strcat s "                              ") 1 len)
  268. )
  269.  
  270. ;  Return the value associated with a particular entity field
  271.  
  272. (defun fld (num lst)
  273.    (cdr (assoc num lst))
  274. )
  275.  
  276. ;  Set up to process specified symbol table.  If TBLSORT is not yet
  277. ;  defined, ask user whether the entries should be sorted.  If sorting
  278. ;  is enabled, obtain all entries and sort them forming TBLENTS list.
  279.  
  280. (defun tblset (tbl / new s)
  281.   (textscr)
  282.   (setq tblname tbl)                    ; set table name
  283.   (if (null tblsort) (progn             ; sorting not yet determined
  284.      (initget 1 "Yes No")               ; Establish keywords, no null
  285.      (setq s (getkword "\nSort the entries (Y/N) ? "))
  286.      (setq tblsort (if (= s "Yes") 1 0))
  287.   ))
  288.   (if (= tblsort 1) (progn              ; if sorting is enabled
  289.      (setq tblents nil)                 ; start with null list
  290.      (setq new (cdr (assoc 2 (tblnext tbl T))))   ; get first entry name
  291.      (while new
  292.         (setq tblents (cons new tblents))         ; add to list
  293.         (setq new (cdr (assoc 2 (tblnext tbl))))  ; get next entry name
  294.      )
  295.      (setq tblents (str-sort tblents))            ; sort the name list
  296.   ))
  297. )
  298.  
  299. ;  Obtain next (or first) entry from table, or from sorted entry list.
  300.  
  301. (defun next (first / temp)
  302.    (if (= tblsort 1) (progn             ; if sorting enabled
  303.       (setq temp (car tblents))         ; get next name from list
  304.       (if temp (progn                   ; if not end of list...
  305.          (setq tblents (cdr tblents))   ; chop from list
  306.          (tblsearch tblname temp)       ; get table entry for this name
  307.       ))
  308.     )
  309.     (tblnext tblname first)             ; else get next (or first) table entry
  310.    )
  311. )
  312.  
  313. ;  Sort a list of strings.
  314.  
  315. (defun str-sort (x)
  316.   (cond ((null (cdr x)) x)
  317.         (T (str-merge (str-sort (first-half x))
  318.                       (str-sort (last-half x))))))
  319.  
  320. (defun str-merge (a b)
  321.   (cond ((null a) b)
  322.         ((null b) a)
  323.         ((< (strcmp (car a) (car b)) 0)
  324.            (cons (car a) (str-merge (cdr a) b)))
  325.         (t (cons (car b) (str-merge a (cdr b))))))
  326.  
  327. (defun first-half (l)
  328.   (head l (1- (length l))))
  329.  
  330. (defun head (l n)
  331.   (cond ((minusp n) nil)
  332.         (t (cons (car l) (head (cdr l) (- n 2))))))
  333.  
  334. (defun last-half (l)
  335.   (tail l (1- (length l))))
  336.  
  337. (defun tail (l n)
  338.   (cond ((minusp n) l)
  339.         (t (tail (cdr l) (- n 2)))))
  340.  
  341. ;  Compare two strings.  Return 0 if they are equal, -1 if the
  342. ;  first string is less than the second in ASCII collating sequence,
  343. ;  and 1 if the second string is less than the first.
  344.  
  345. (defun strcmp (a b)
  346.   (cond ((= a b) 0)
  347.         (T (cond ((< (ascii a) (ascii b)) -1)
  348.                  ((> (ascii a) (ascii b))  1)
  349.                  (t (strcmp (substr a 2) (substr b 2)))))))
  350.  
  351.  
  352. ;  Dump all the symbol tables
  353.  
  354. (defun C:TABLES ()
  355.    (setq tblsort nil)                 ; Force "Sort Y/N" query
  356.    (layers)
  357.    (ltypes)
  358.    (views)
  359.    (styles)
  360.    (blocks)
  361. )
  362.